COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00017 ENDMK
C⊗;


(DEFPROP COMPFCNS
 (COMPFCNS COMPL
	   COMP
	   SUBSTACK
	   PRUP
	   MKPUSH
	   COMPEXP
	   STACKUP
	   CCCHAIN
	   COMPC
	   COMCOND
	   COMPLISA
	   CCOUNT
	   LOADAC
	   COMPLIS
	   CLASSIFY
	   CLASS1
	   CLASS2
	   MKJRST
	   COMBOOL
	   COMPANDOR
	   COMPANDOR1
	   FLAT)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (PROG	(Z)
	(EVAL
	 (CONS (QUOTE OUTPUT)
	       (CONS (QUOTE DSK:)
		     (LIST (CONS (CAR FILE) (QUOTE LAP))))))
	(EVAL (CONS (QUOTE INPUT) (CONS (QUOTE DSK:) FILE)))
	(INC (QUOTE T) NIL)
	(OUTC T NIL)
   LOOP	(SETQ Z (ERRSET (READ)))
	(COND ((ATOM Z) (GO DONE)) ((QUOTE T) (QUOTE NIL)))
	(SETQ Z (CAR Z))
	(COND ((OR (EQ (CAR Z) (QUOTE DE))
		   (AND	(EQ (CAR Z) (QUOTE DEFPROP))
			(EQ (CADDDR Z) (QUOTE EXPR))))
	       (PROG (PROG)
		     (SETQ PROG
			   (COND ((EQ (CAR Z) (QUOTE DE))
				  (COMP	(CADR Z)
					(CADDR Z)
					(CADDDR Z)))
				 (T
				  (COMP	(CADR Z)
					(CADR (CADDR Z))
					(CADDR (CADDR Z))))))
		     (MAPC (FUNCTION PRINT) PROG)
		     (OUTC NIL NIL)
		     (PRINT (LIST (CADR Z) (LENGTH PROG)))
		     (OUTC T NIL)))
	      (T (PRINT Z)))
	(GO LOOP)
   DONE	(OUTC NIL T)
	(INC NIL T)
	(RETURN (QUOTE ENDCOMP))))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(VPR N)
    (FLAT (LIST	(LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
		(MKPUSH N 1)
		(COMPEXP EXP (MINUS N) VPR)
		(SUBSTACK N)
		(QUOTE ((POPJ P) (LABEL NIL))))
	  NIL))
   (PRUP VARS 1)
   (LENGTH VARS)))
EXPR)

(DEFPROP SUBSTACK
 (LAMBDA(N)
  (COND	((EQ N 0) NIL)
	(T
	 (LIST
	  (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE C) N 0 N 0))))))
EXPR)

(DEFPROP PRUP
 (LAMBDA(VARS N)
  (COND	((NULL VARS) NIL)
	(T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (PLUS N 1))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA(N M)
  (COND	((LESSP N M) NIL)
	(T
	 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
	       (MKPUSH N (PLUS M 1))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((OR (EQ EXP (QUOTE T)) (NUMBERP EXP))
	 (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP)
	 (LIST
	  (LIST	(QUOTE MOVE)
		1
		(PLUS M (CDR (ASSOC EXP VPR)))
		(QUOTE P))))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ@)
		       1
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HLRZ@ 1 1)))))))
	((EQ (CAR EXP) (QUOTE CDR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HRRZ@)
		       1
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HRRZ@ 1 1)))))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT))
	     (EQ (CAR EXP) (QUOTE EQ)))
	 ((LAMBDA(L1 L2)
	   (LIST (COMBOOL EXP M L1 NIL VPR)
		 (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		       (LIST (QUOTE JRST) 0 L2)
		       (LIST (QUOTE LABEL) L1)
		       (QUOTE (MOVEI 1 0))
		       (LIST (QUOTE LABEL) L2))))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND))
	 (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE))
	 (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 (LIST (COMPLISA (CDR EXP) M VPR)
	       (LIST
		(LIST (QUOTE CALL)
		      (LENGTH (CDR EXP))
		      (LIST (QUOTE E) (CAR EXP))
		      (QUOTE S)))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (LIST (STACKUP (CDR EXP) M VPR)
		 (COMPEXP
		  (CADDAR EXP)
		  (DIFFERENCE M N)
		  (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		 (SUBSTACK N)))
	  (LENGTH (CDR EXP))))
	((QUOTE T) (QUOTE NIL))))
EXPR)

(DEFPROP STACKUP
 (LAMBDA(U M VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMPEXP (CAR U) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (STACKUP (CDR U) (DIFFERENCE M 1) VPR)))))
EXPR)

(DEFPROP CCCHAIN
 (LAMBDA(EXP)
  (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR)))
       (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))
EXPR)

(DEFPROP COMPC
 (LAMBDA(EXP N2 M VPR)
  (COND	((ATOM EXP) (ERR (QUOTE COMPC)))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ@)
		       N2
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(CONS (LIST (QUOTE HLRZ@) N2 N2)
		      (COMPC (CADR EXP) N2 M VPR)))))
	((ATOM (CADR EXP))
	 (LIST
	  (LIST	(QUOTE HRRZ@)
		N2
		(PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		(QUOTE P))))
	(T
	 (CONS (LIST (QUOTE HRRZ@) N2 N2)
	       (COMPC (CADR EXP) N2 M VPR)))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST (LIST (QUOTE LABEL) L)))
	((AND (NOT (ATOM (CAAR U)))
	      (EQ (CAAAR U) (QUOTE NULL))
	      (NULL (CADAR U)))
	 (LIST (COMPEXP (CADAAR U) M VPR)
	       (LIST (LIST (QUOTE JUMPE) 1 L))
	       (COMCOND (CDR U) M L VPR)))
	((EQ (CAAR U) (QUOTE T))
	 (LIST (COMPEXP (CADAR U) M VPR)
	       (LIST (LIST (QUOTE LABEL) L))))
	(T
	 ((LAMBDA(L1)
	   (LIST (COMBOOL (CAAR U) M L1 NIL VPR)
		 (COMPEXP (CADAR U) M VPR)
		 (LIST (LIST (QUOTE JRST) 0 L)
		       (LIST (QUOTE LABEL) L1))
		 (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))
EXPR)

(DEFPROP COMPLISA
 (LAMBDA(U M VPR)
  ((LAMBDA(Z)
    (LIST (COMPLIS Z M 1 VPR)
	  (LOADAC Z
		  (DIFFERENCE 1 (CCOUNT Z))
		  1
		  (DIFFERENCE M (CCOUNT Z))
		  VPR)
	  (SUBSTACK (CCOUNT Z))))
   (CLASSIFY U)))
EXPR)

(DEFPROP CCOUNT
 (LAMBDA(Z)
  (COND	((NULL Z) 0)
	((EQ (CAAR Z) 4) (PLUS 1 (CCOUNT (CDR Z))))
	(T (CCOUNT (CDR Z)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(Z M2 N2 M VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 1)
	 (CONS (LIST (QUOTE MOVE)
		     N2
		     (PLUS M (CDR (ASSOC (CDAR Z) VPR)))
		     (QUOTE P))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 0)
	 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z)))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 2)
	 (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 3)
	 (LIST (REVERSE (COMPC (CDAR Z) N2 M VPR))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 5) (LOADAC (CDR Z) 1 (PLUS N2 1) M VPR))
	(T
	 (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P))
	       (LOADAC (CDR Z) (PLUS M2 1) (PLUS N2 1) M VPR)))))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(Z M K VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 4)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (COMPLIS (CDR Z) (DIFFERENCE M 1) (PLUS K 1) VPR)))
	((EQ (CAAR Z) 5)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (COND ((EQ K 1) NIL)
		     (T (LIST (LIST (QUOTE MOVE) K 1))))))
	(T (COMPLIS (CDR Z) M (PLUS K 1) VPR))))
EXPR)

(DEFPROP CLASSIFY
 (LAMBDA (U) (CLASS2 (CLASS1 U NIL) NIL T))
EXPR)

(DEFPROP CLASS1
 (LAMBDA(U V)
  (COND	((NULL U) V)
	((ATOM (CAR U))
	 (COND ((OR (EQUAL (CAR U) (QUOTE NIL))
		    (EQUAL (CAR U) (QUOTE T))
		    (NUMBERP (CAR U)))
		(CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
	       (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
	((EQUAL (CAAR U) (QUOTE QUOTE))
	 (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
	((CCCHAIN (CAR U))
	 (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
	(T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))
EXPR)

(DEFPROP CLASS2
 (LAMBDA(U V FLG)
  (COND	((NULL U) V)
	((AND FLG (EQ (CAAR U) 4))
	 (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
	(T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))
EXPR)

(DEFPROP MKJRST
 (LAMBDA (L) (LIST (LIST (QUOTE JRST) 0 L)))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((EQ P (QUOTE T)) (COND (FLG (MKJRST L)) (T NIL)))
	((ATOM P)
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))
	((EQ (CAR P) (QUOTE EQ))
	 (LIST (COMPLISA (CDR P) M VPR)
	       (COND (FLG (QUOTE ((CAMN 1 2))))
		     (T (QUOTE ((CAME 1 2)))))
	       (MKJRST L)))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L NIL VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L T VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT))
	 (COMBOOL (CADR P) M L (NOT FLG) VPR))
	((EQ (CAR P) (QUOTE NULL))
	 (LIST (COMPEXP (CADR P) M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPE)) (T (QUOTE JUMPN)))
		      1
		      L))))
	(T
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)

(DEFPROP COMPANDOR1
 (LAMBDA(U M L L2 FLG VPR)
  (COND	((NULL U) (MKJRST L2))
	((NULL (CDR U)) (COMBOOL (CAR U) M L2 (NOT FLG) VPR))
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR1 (CDR U) M L L2 FLG VPR)))))
EXPR)

(DEFPROP FLAT
 (LAMBDA(U S)
  (COND	((NULL U) S)
	((NULL (CAR U)) (FLAT (CDR U) S))
	((EQ (CAR U) (QUOTE LABEL)) (CONS (CADR U) S))
	((ATOM (CAR U)) (CONS U S))
	(T (FLAT (CAR U) (FLAT (CDR U) S)))))
EXPR)